let make_timer () =
  let date_depart = ref 0. in
  let date_expiration = ref None in
  let temps_restant = ref 0. in
  let pause () =
    match !date_expiration with
    | Some date ->
       let () = temps_restant := !temps_restant -. (date -. !date_depart) in
       date_expiration := None
    | None -> ()
  in
  let restant () =
    let mtn = Unix.gettimeofday () in
    match !date_expiration with
    | Some d when d <= mtn ->
       let () = pause () in
       0.
    | Some d -> (d -. mtn)
    | None -> !temps_restant
  in
  let reprendre () =
    match !date_expiration with
    | Some _ -> ()
    | None ->
       let () = date_depart := Unix.gettimeofday () in
       date_expiration := Some (!date_depart +. !temps_restant)
  in
  let ajouter_temps tps =
    let () = temps_restant := !temps_restant +. tps in
    match !date_expiration with
    | None -> ()
    | Some date -> date_expiration := Some (date +. tps)
  in
  let regler delai =
    let mtn = Unix.gettimeofday () in
    let () = temps_restant := delai in
    let () = match !date_expiration with
      | None -> ()
      | Some date -> date_expiration := Some (mtn +. delai)
    in
    date_depart := mtn
  in
  (restant, pause, reprendre, ajouter_temps, regler)

let make_timer fonction =
  let ok = ref false in
  let (restant, pause, reprendre, ajouter_temps, regler) = make_timer () in
  let rec check () =
    if not !ok then
      let restant = restant () in
      if restant = 0. then
	let () = ok := true in
	fonction ()
      else ignore (Lwt.bind (Lwt_unix.sleep restant) (fun () -> Lwt.return (check ())))
    else ()
  in
  let pause () =
    let () = ok := false in
    let () = pause () in
    ()
  in
  let reprendre () =
    let () = ok := true in
    let () = reprendre () in
    check ()
  in
  let ajouter_temps delai =
    let () = ajouter_temps delai in
    check ()
  in
  let regler temps =
    let () = regler temps in
    check ()
  in
  (pause, reprendre, ajouter_temps, regler)

type socket =
  {
    envoyer: Protocole.msg -> unit;
    deconnecter: unit -> unit 
  }

let table_sockets = Hashtbl.create 1

let s = Serveur.make ()

let serveur_lwt = ref None
		      
let jouer_serveur flux_entree ecrire =
  (* let () =  print_endline "Nouveau client !\n" in *)
  let lecteur = Protocole.lire_message () in
  let nom = ref None in
  let push message =
    let octets = Protocole.ecrire_message message in
    Array.iter (ecrire) octets
  in
  let (fin_demandee, finir) = Lwt.wait () in
  let close () = Lwt.wakeup finir () in
  let lire_caractere c =
    let () = 
      match lecteur c with
      | None -> ()
      | Some message -> 
	 match !nom with
	 | None -> (* Il faut s'identifier *)
	    let valider = function
	      | None -> 
		 push Protocole.Refuse
	      | Some mon_nom ->
		 let () = nom := Some mon_nom in
		 Hashtbl.add table_sockets mon_nom
			     {envoyer = push ; deconnecter = close}
	    in
	    Serveur.nouveau_client s (fun _ -> true)
				   (valider) message
	 | Some nom ->
	    Serveur.assimiler_message s nom message
    in
    Lwt.return ()
  in
  let fin_entree = Lwt_stream.iter_s (lire_caractere) flux_entree in
  let fin = Lwt.pick [fin_demandee ; fin_entree] in
  let fin =
    Lwt.bind fin
	     (fun () -> 
	      match !nom with
	      | None -> Lwt.return ()
	      | Some nom -> try 
			    Lwt.return
			      (Serveur.enregistrer_deconnexion s nom)
			  with Not_found -> Lwt.return ())
  in
  fin

let lancer_interface_web () =
  let fallback_peek =
    Eliom_service.Http.service
      ~path:["jeu" ; "lire"]
      ~get_params:Eliom_parameter.unit
      ()
  in
  let service_peek =
    Eliom_service.Http.post_service
      ~fallback:fallback_peek
      ~post_params:(Eliom_parameter.string "id_connexion")
      ()
  in
  let fallback_pop =
    Eliom_service.Http.service
      ~path:["jeu" ; "suivant"]
      ~get_params:Eliom_parameter.unit
      ()
  in
  let service_pop =
    Eliom_service.Http.post_service
      ~fallback:fallback_pop
      ~post_params:(Eliom_parameter.string "id_connexion")
      ()
  in
  let fallback_push =
    Eliom_service.Http.service
      ~path:["jeu" ; "envoyer"]
      ~get_params:Eliom_parameter.unit
      ()
  in
  let service_push =
    Eliom_service.Http.post_service
      ~fallback:fallback_push
      ~post_params:Eliom_parameter.((string "id_connexion") ** (string "message"))
				     ()
  in
  let (clients :
	 (string,
	  ((Protocole.msg -> unit)       (* Entrée du serveur *)
	   * (Protocole.msg Lwt_stream.t) (* À récupérer par le client *)
	  )) Hashtbl.t) =
    Hashtbl.create 1 in
  let (sursis :
	 (string,
	  (* pause          reprendre        ajouter           définir *)
	  (unit -> unit) * (unit -> unit) * (float -> unit) * (float -> unit))
	   Hashtbl.t) = Hashtbl.create 1 in
  let mettre_en_pause id_client =
    try
      let (pause, _, _, _) = Hashtbl.find sursis id_client in
      pause ()
    with Not_found -> ()
  in
  let relancer_chrono id_client delai =
    try
      let (pause, reprendre, _, definir) = Hashtbl.find sursis id_client in
      let () = pause () in
      let () = definir delai in
      reprendre ()
    with Not_found -> ()
  in
  let peek id_connexion =
    let () = mettre_en_pause id_connexion in
    let to_hex =
      let zero = int_of_char '0' in
      let a = int_of_char 'a' in
      let aux x =
	if x < 10 then char_of_int (zero + x)
	else char_of_int (a + x - 10)
      in
      aux
    in
    let chaine =
      try
	let (_, flux) = Hashtbl.find clients id_connexion in
	Lwt.bind (Lwt_stream.peek flux)
		 (function
		   | None -> Lwt.return ""
		   | Some msg ->
		      let octets = Protocole.ecrire_message msg in
		      let demi_octets = Array.map (fun o ->
						   [(o lsr 4) land 0b1111 ;
						    o land 0b1111])
						  octets in
		      let lettres = Array.map (List.map (to_hex)) demi_octets in
		      let lettres = Array.to_list lettres in
		      let lettres = List.concat lettres in
		      let lettres = List.map (String.make 1) lettres in
		      let chaine = String.concat "" lettres in
		      Lwt.return chaine)		    
      with Not_found -> Lwt.return ""
    in
    Lwt.bind chaine
	     (fun chaine ->
	      let () = relancer_chrono id_connexion 10. in
	      Lwt.return chaine)
  in
  let pop id_connexion =
    try
      let (_, flux) = Hashtbl.find clients id_connexion in
      Lwt_stream.junk flux
    with Not_found -> Lwt.return ()
  in
  let push id_connexion message_string =
    let lecteur =
      let lecteur = Protocole.lire_message () in
      let mem = ref None in
      let demi_lecteur demi_octet =
	match !mem with
	| None ->
	   let () = mem := Some demi_octet in
	   None
	| Some d ->
	   let () = mem := None in
	   let octet = ((d lsl 4) lor demi_octet) in
	   lecteur octet
      in
      let demi_lecteur_caractere c =
	demi_lecteur
	  (match c with
	   | '0' -> 0 | '4' -> 4 | '8'       -> 8  | 'c' | 'C' -> 12
	   | '1' -> 1 | '5' -> 5 | '9'       -> 9  | 'd' | 'D' -> 13
	   | '2' -> 2 | '6' -> 6 | 'a' | 'A' -> 10 | 'e' | 'E' -> 14
	   | '3' -> 3 | '7' -> 7 | 'b' | 'B' -> 11 | 'f' | 'F' -> 15
	   | _ -> failwith "Mauvais format")
      in
      demi_lecteur_caractere
    in
    try
      let (ajouter_requete, _) = Hashtbl.find clients id_connexion in
      let rec decoder i =
	if i < String.length message_string then
	  let () = 
	    try match lecteur message_string.[i] with
		| None -> ()
		| Some requete -> ajouter_requete requete
	    with Failure "Mauvais format" -> ()
	  in
	  decoder (i + 1)
	else ()
      in
      let () = decoder 0 in
      Lwt.return true
    with Not_found -> Lwt.return false
  in
  let nouvelle_connexion () =
    let (flux_requetes, ajouter_requete) = Lwt_stream.create () in
    let (flux_requetes_char, ajouter_requete_char) = Lwt_stream.create () in
    (* Transvase le flux entrant de messages vers un flux entrant d'octets (int) *)
    let _ = Lwt_stream.iter
			 (fun requete ->
			  let octets = Protocole.ecrire_message requete in
			  let some_octets = Array.map (fun x -> Some x) octets in
			  Array.iter (ajouter_requete_char) some_octets)
			 flux_requetes in
    let (flux_reponses_char, ajouter_reponse_char) = Lwt_stream.create () in
    let lecteur = Protocole.lire_message () in
    let (flux_reponses, ajouter_reponse) = Lwt_stream.create () in
    (* Transvase le flux sortant d'octets vers un flux de réponses *)
    let _ = Lwt_stream.iter
			 (fun octet ->
			  match lecteur octet with
			  | None -> ()
			  | Some reponse -> ajouter_reponse (Some reponse))
			 flux_reponses_char in
    let id = Ocsigen_lib.make_cryptographic_safe_string () in
    let () = Hashtbl.add clients id ((fun r -> ajouter_requete (Some r)),
				     flux_reponses) in
    let fin = jouer_serveur flux_requetes_char (fun c -> ajouter_reponse_char (Some c)) in
    let _ = Lwt.bind fin (fun () ->
			  let () = Hashtbl.remove clients id in
			  Lwt.return (Hashtbl.remove sursis id)) in
    let quitter () = ajouter_requete_char None in
    let fonctions = make_timer (quitter) in
    let () = Hashtbl.add sursis id fonctions in
    let () = Printf.printf "%s\n%!" id in
    id
  in
  let () = Eliom_registration.String.register
	     ~service:fallback_peek
	     (fun () () -> Lwt.return (nouvelle_connexion (), "text/plain"))
  in
  let () = Eliom_registration.String.register
	     ~service:fallback_pop
	     (fun () () -> Lwt.return (nouvelle_connexion (), "text/plain"))
  in
  let () = Eliom_registration.String.register
	     ~service:fallback_push
	     (fun () () -> Lwt.return (nouvelle_connexion (), "text/plain"))
  in
  let () = Eliom_registration.String.register
	     ~service:service_peek
	     (fun () id_connexion ->
	      Lwt.bind (peek id_connexion)
		       (fun msg -> Lwt.return (msg, "text/plain"))) in
  let () = Eliom_registration.Unit.register
	     ~service:service_pop
	     (fun () id_connexion ->
	      pop id_connexion) in
  let () = Eliom_registration.String.register
	     ~service:service_push
	     (fun () (id_connexion, message) ->
	      Lwt.bind (push id_connexion message)
		       (function true -> Lwt.return ("oui", "text/plain")
			       | false -> Lwt.return ("non", "text/plain"))) in
  let () = Printf.printf "Services de jeu web définis.\n%!" in
  ()
  
      
let init finir_partie =
  let () = Serveur.set_suiveur
	     s (fun client t msg -> Printf.printf "%s : [%s] %s\n%!"
						  client t msg) in
  let () = Serveur.set_finisseur
	     s (finir_partie s) in
  let () = Serveur.set_envoyer s
    (fun nom -> 
      try (Hashtbl.find table_sockets nom).envoyer
      with Not_found -> (ignore)) in
  let () = Serveur.set_deconnecter s
    (fun nom ->
      try (Hashtbl.find table_sockets nom).deconnecter ()
      with Not_found -> ()) in
  let () = serveur_lwt := Some (
    Lwt_io.establish_server 
      (Unix.ADDR_INET (Unix.inet_addr_any, 45678)) 
      (fun (chan_in, chan_out) ->
       let (flux_chars, push_char) = Lwt_stream.create () in
       let _ = Lwt_io.write_chars chan_out flux_chars in
       let chars_entree = Lwt_io.read_chars chan_in in
       let ints_entree = Lwt_stream.map (int_of_char) chars_entree in
       let fin_client =
	 jouer_serveur ints_entree
		       (fun i -> push_char (Some (char_of_int i))) in
       let _ = Lwt.bind fin_client
			(fun () -> Lwt.join
				     [Lwt_io.close chan_in ;
				      Lwt_io.close chan_out]) in
       ()
      )) in
  let () = lancer_interface_web () in
  print_endline "Le serveur liste..."
